home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / mops / support.scm < prev    next >
Text File  |  1993-07-23  |  8KB  |  270 lines
  1. ; Mode: Scheme
  2. ;
  3. ;
  4. ; *************************************************************************
  5. ; Copyright (c) 1992 Xerox Corporation.  
  6. ; All Rights Reserved.  
  7. ;
  8. ; Use, reproduction, and preparation of derivative works are permitted.
  9. ; Any copy of this software or of any derivative work must include the
  10. ; above copyright notice of Xerox Corporation, this paragraph and the
  11. ; one after it.  Any distribution of this software or derivative works
  12. ; must comply with all applicable United States export control laws.
  13. ;
  14. ; This software is made available AS IS, and XEROX CORPORATION DISCLAIMS
  15. ; ALL WARRANTIES, EXPRESS OR IMPLIED, INCLUDING WITHOUT LIMITATION THE
  16. ; IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
  17. ; PURPOSE, AND NOTWITHSTANDING ANY OTHER PROVISION CONTAINED HEREIN, ANY
  18. ; LIABILITY FOR DAMAGES RESULTING FROM THE SOFTWARE OR ITS USE IS
  19. ; EXPRESSLY DISCLAIMED, WHETHER ARISING IN CONTRACT, TORT (INCLUDING
  20. ; NEGLIGENCE) OR STRICT LIABILITY, EVEN IF XEROX CORPORATION IS ADVISED
  21. ; OF THE POSSIBILITY OF SUCH DAMAGES.
  22. ; *************************************************************************
  23. ;
  24. ;
  25. ; Scheme is such a wonderful language, you can't program in it!
  26. ;
  27. ; This is a library of stuff I find useful.  I'll bet there's dozens
  28. ; of these out there.
  29. ;
  30.  
  31. ;
  32. ; In order to make this code more easily portable, we have to be
  33. ; explicit about its implementation dependencies.  To do this, we
  34. ; have the following variable.  Please adjust it before trying to
  35. ; run this code.  See also the macro, scheme-implementation-case,
  36. ; which follows shortly.
  37. ;
  38. ; Note that some of these dependencies (i.e. gsort) are purely for
  39. ; convenience (i.e. saving me from writing sort from scratch).
  40. ; Others are more pressing, like define-macro.
  41. ;
  42. ;
  43. (define what-scheme-implementation
  44.   'mit
  45.  ;'chez
  46.   )
  47.  
  48. (case what-scheme-implementation
  49.   ((mit)
  50.    (syntax-table/define                    ;Kind of like DEFMACRO
  51.      user-initial-syntax-table             ;  lifted from Cornell.
  52.      'DEFINE-MACRO
  53.      (macro (formals . body)
  54.         (if (not (pair? formals))
  55.         (error "DEFINE-MACRO: First argument must be formals."))
  56.         `(SYNTAX-TABLE-DEFINE
  57.            USER-INITIAL-SYNTAX-TABLE
  58.            (QUOTE ,(car formals))
  59.            ,(append (list 'MACRO (cdr formals)) body)))))
  60.   ((chez)
  61.    ???))
  62.  
  63.  
  64. (define gsort
  65.   (case what-scheme-implementation
  66.     ((mit)  (lambda (predicate list) (sort list predicate)))
  67.     ((chez) (lambda (predicate list) (sort predicate list)))))
  68.  
  69. (define simple-printer (lambda () barf))
  70.  
  71.  
  72.  
  73.  
  74. (define ??? 'unspecified-result)
  75.  
  76. (define list*
  77.   (lambda args
  78.     (letrec ((chase
  79.           (lambda (args)
  80.         (cond ((null? args) '())
  81.               ((null? (cdr args)) (car args))
  82.               (else (cons (car args) (chase (cdr args))))))))
  83.       (chase args))))
  84.  
  85. (define apply*
  86.     (lambda (proc . args)
  87.       (apply proc (apply list* args))))
  88.  
  89.  
  90. (define position-of
  91.     (lambda (x lst)
  92.       (if (eq? x (car lst)) 0 (+ 1 (position-of x (cdr lst))))))
  93.  
  94. (define map-append
  95.     (lambda (proc . lists)
  96.       (apply append (apply map (cons proc lists)))))
  97.  
  98. (define last
  99.     (lambda (l)
  100.       (if (null? l)
  101.       #f
  102.       (if (null? (cdr l))
  103.           (car l)
  104.           (last (cdr l))))))
  105.  
  106. (define every
  107.     (lambda (test . lists)
  108.       (let scan ((tails lists))
  109.     (if (member #t (map null? tails))             ;(any null? lists)
  110.         #t
  111.         (and (apply test (map car tails))
  112.          (scan (map cdr tails)))))))
  113.  
  114. (define remove
  115.     (lambda (x list)
  116.       (cond ((null? list) '())
  117.         ((eq? (car list) x) (cdr list))
  118.         (else (cons (car list) (remove x (cdr list)))))))
  119.  
  120. (define getl
  121.     (lambda (initargs name . not-found)
  122.       (letrec ((scan (lambda (tail)
  123.                (cond ((null? tail)
  124.                   (if (pair? not-found)
  125.                   (car not-found)
  126.                   (error "GETL couldn't find" name)))
  127.                  ((eq? (car tail) name) (cadr tail))
  128.                  (else (scan (cddr tail)))))))
  129.     (scan initargs))))
  130.  
  131. (define union
  132.     (lambda lists
  133.       (letrec ((clean (lambda (list result)
  134.             (cond ((null? list) result)
  135.                   ((memq (car list) result)
  136.                    (clean (cdr list) result))
  137.                   (else
  138.                    (clean (cdr list) (cons (car list) result)))))))
  139.     (clean (apply append lists) '()))))
  140.  
  141. (define filter-in
  142.     (lambda (f l)
  143.       (cond ((null? l) '())
  144.         ((f (car l)) (cons (car l) (filter-in f (cdr l))))
  145.         (else (filter-in f (cdr l))))))
  146.  
  147. (define collect-if
  148.     (lambda (test? list)
  149.       (cond ((null? list) '())
  150.         ((test? (car list)) (cons (car list) (collect-if test? (cdr list))))
  151.         (else (collect-if test? (cdr list))))))
  152.  
  153. ;(define remove-unless
  154. ;    (lambda (test list)
  155. ;      (if (null? list)
  156. ;      ()
  157. ;      (let ((rest (remove-unless test (cdr list))))
  158. ;        (if (test (car list))
  159. ;        (cons (car list) rest)
  160. ;        rest)))))
  161.  
  162. (define remove-duplicates
  163.     (lambda (list)
  164.       (let loop ((result-so-far '())
  165.          (remaining list))
  166.        (if (null? remaining)
  167.            result-so-far
  168.            (if (null? (memq (car remaining) result-so-far))
  169.            (loop (cons (car remaining) result-so-far)
  170.              (cdr remaining))
  171.            (loop result-so-far
  172.              (cdr remaining)))))))
  173.  
  174.  
  175.  
  176.  
  177. ;
  178. ; A simple topological sort.
  179. ;
  180. ; It's in this file so that both TinyClos and Objects can use it.
  181. ;
  182. ; This is a fairly modified version of code I originally got from Anurag
  183. ; Mendhekar <anurag@moose.cs.indiana.edu>.
  184. ;
  185. ;
  186.  
  187. (define compute-std-cpl
  188.     (lambda (c get-direct-supers)
  189.       (top-sort ((build-transitive-closure get-direct-supers) c)
  190.         ((build-constraints get-direct-supers) c)
  191.         (std-tie-breaker get-direct-supers))))
  192.  
  193.  
  194. (define top-sort
  195.     (lambda (elements constraints tie-breaker)
  196.       (let loop ((elements    elements)
  197.          (constraints constraints)
  198.          (result      '()))
  199.     (if (null? elements)
  200.         result
  201.         (let ((can-go-in-now
  202.             (filter-in
  203.               (lambda (x)
  204.             (every (lambda (constraint)
  205.                  (or (not (eq? (cadr constraint) x))
  206.                      (memq (car constraint) result)))
  207.                    constraints))
  208.               elements)))
  209.           (if (null? can-go-in-now)
  210.           (error 'top-sort "Invalid constraints")
  211.           (let ((choice (if (null? (cdr can-go-in-now))
  212.                     (car can-go-in-now)
  213.                     (tie-breaker result
  214.                          can-go-in-now))))
  215.             (loop
  216.               (filter-in (lambda (x) (not (eq? x choice)))
  217.                      elements)
  218.              ;(filter-in (lambda (x) (not (eq? (cadr x) choice)))
  219.              ;           constraints)
  220.               constraints
  221.               (append result (list choice))))))))))
  222.  
  223. (define std-tie-breaker
  224.     (lambda (get-supers)
  225.       (lambda (partial-cpl min-elts)
  226.     (let loop ((pcpl (reverse partial-cpl)))
  227.          (let ((current-elt (car pcpl)))
  228.            (let ((ds-of-ce (get-supers current-elt)))
  229.          (let ((common (filter-in (lambda (x)
  230.                         (memq x ds-of-ce))
  231.                       min-elts)))
  232.            (if (null? common)
  233.                (if (null? (cdr pcpl))
  234.                (error 'std-tie-breaker "Nothing valid")
  235.                (loop (cdr pcpl)))
  236.                (car common)))))))))
  237.  
  238.  
  239. (define build-transitive-closure
  240.     (lambda (get-follow-ons)
  241.       (lambda (x)
  242.     (let track ((result '())
  243.             (pending (list x)))
  244.          (if (null? pending)
  245.          result
  246.          (let ((next (car pending)))
  247.            (if (memq next result)
  248.                (track result (cdr pending))
  249.                (track (cons next result)
  250.                   (append (get-follow-ons next)
  251.                       (cdr pending))))))))))
  252.  
  253. (define build-constraints
  254.   (lambda (get-follow-ons)
  255.     (lambda (x)
  256.       (let loop ((elements ((build-transitive-closure get-follow-ons) x))
  257.          (this-one '())
  258.          (result '()))
  259.        (if (or (null? this-one) (null? (cdr this-one)))
  260.            (if (null? elements)
  261.            result
  262.            (loop (cdr elements)
  263.              (cons (car elements)
  264.                    (get-follow-ons (car elements)))
  265.              result))
  266.            (loop elements
  267.              (cdr this-one)
  268.              (cons (list (car this-one) (cadr this-one))
  269.                result)))))))
  270.